home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / RULES / Rule-Defs.lisp < prev    next >
Encoding:
Text File  |  1990-06-25  |  11.3 KB  |  256 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         Rule-Defs.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      19-Oct-88 21:57:32
  17. ; Modified:     22-Jun-90 02:19:38 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      RULE
  20. ;
  21. ; Description:  Rule-based reasoner built on the pattern matching facilities
  22. ;               of DNET.  Supports forward and backward reasoning.
  23. ;
  24. ;               This file contains essential definitions only: those which
  25. ;               are used by all other Rule code, or which the user always 
  26. ;               needs to create and access data structures. See also
  27. ;               RULES, Rule-Build, Rule-Forward, and Rule-Back.
  28. ;               File RULES has documentation.
  29. ;
  30. ; (c) Copyright 1988, by Daniel D. Suthers
  31. ;                        Department of Computer and Information Science
  32. ;                        University of Massachusetts
  33. ;                        Amherst, Massachusetts 01003
  34. ;
  35. ; This software was conceived, designed, and written by Dan Suthers 
  36. ; while supported by the National Science Foundation under grant number
  37. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  38. ; CA.  Partial support was also received from the Office of Naval Research
  39. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  40. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  41. ; the above grants and encouraged me to pursue my own research interests in
  42. ; her lab.  This work would not have been possible without the resources and
  43. ; stimulating environment of the Computer and Information Science department.
  44. ;
  45. ; Permission to use, modify, and distribute this software is granted subject 
  46. ; to the following restrictions and understandings:
  47. ; 1. The file header, including this notice, shall be retained, and may be
  48. ;    extended to include documentation of modifications to the software.
  49. ; 2. This material is for nonprofit educational and research purposes only.
  50. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  51. ;    noteworthy uses of this software.
  52. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  53. ;    representation that the operation of this software will be error free,
  54. ;    and are under no obligation to provide any services.
  55. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  56. ;    Suthers and the University of Massachusetts from all claims arising 
  57. ;    out of the use or misuse of this software, or arising out of any 
  58. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  59. ;    fees, and liabilities incurred in or about any such claim, action, or
  60. ;    proceeding brought thereon.
  61. ; 5. All materials and reports developed as a consequence of the use of 
  62. ;    this software shall duly acknowledge such use, in accordance with
  63. ;    the usual standards of acknowledging credit in academic research.
  64. ;
  65. ; Status:       Working.
  66. ;
  67. ; Changes:
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69.  
  70. (in-package :RULE)
  71.  
  72. (export '(
  73.           *rule-trace*
  74.  
  75.           add-datum
  76.           datum-justification
  77.           delete-datum
  78.           make-data-base
  79.           make-rule-base
  80.  
  81.           justification
  82.           justification-warrant
  83.           justification-grounds
  84.           justification-time
  85.  
  86.           defvariables
  87.  
  88. ;;; Didn't work.  Any ideas?
  89. ;;;          ;; These are shadowed by DNET symbols, so it appears that these DNET
  90. ;;;          ;; functions are in the RULE package.
  91. ;;;          all-expressions
  92. ;;;          defvariable
  93. ;;;          variable-p
  94.  
  95.           ))
  96.  
  97. ;;;(eval-when (eval load)
  98. ;;;  (shadowing-import '(dnet:all-expressions dnet:defvariable dnet:variable-p)))
  99.  
  100. (use-package :DNET)
  101.  
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103. ;;;
  104. ;;;                         ESSENTIAL DATA STRUCTURES
  105. ;;;
  106. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  107.  
  108. (defvar *RULE-TRACE* nil 
  109.   "If non-nil, should be a stream to write trace of rule firings to.")
  110.  
  111. ;;;------------------------------------------------------------------------
  112. ;;; Needed in this file to write ADD-DATUM.
  113.  
  114. (defstruct (JUSTIFICATION (:type vector))
  115.   "One of these is associated with each datum to record where it came from."
  116.   (WARRANT nil)              ; a rule name
  117.   (GROUNDS nil)              ; expressions which made the rule succeed.
  118.   (TIME    0 :type integer)) ; universal time stamp
  119.  
  120. ;;;------------------------------------------------------------------------
  121. ;;; The records which are placed in the DNET-TERMINAL-INFOs which tell us 
  122. ;;; about the rule we just matched to.  This is a variant record, to save 
  123. ;;; space, since few rules need the bindings list.  So I don't use defstruct.  
  124.  
  125. (defun MAKE-RULE-RECORD (rule pattern repeatable)
  126.   (if repeatable (list rule pattern nil) (list rule pattern)))
  127.  
  128. ;;; Must be able to use for mapcar and :test.
  129. (defun RULE-RECORD-RULE-NAME (rule-record)
  130.   (first rule-record))
  131. (defun RULE-RECORD-PATTERN (rule-record)
  132.   (second rule-record))
  133. (defun RULE-RECORD-REPEATABLE (rule-record)
  134.   (not (cddr rule-record)))
  135.  
  136. ;;; Must have setf access.
  137. (defmacro RULE-RECORD-BINDINGS (rule-record)
  138.   `(third ,rule-record))
  139.  
  140. ;;;------------------------------------------------------------------------
  141. ;;; Antecedents and consequents are stored in DNETs labeled with :ANTECEDENT 
  142. ;;; and :CONSEQUENT, to keep the matcher from confusing them.  Thus, query
  143. ;;; patterns must have the same form.  The following templates eliminate the 
  144. ;;; need for any consing, using (setf (cdr *antecedent-template*) <expression>).
  145. ;;; Of course we have to be careful where we use something that will be hacked.
  146.  
  147. (defvar *ANTECEDENT-TEMPLATE* (list :antecedent))
  148. (defvar *CONSEQUENT-TEMPLATE* (list :consequent))
  149.  
  150. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  151. ;;;
  152. ;;;                      INTERNAL FUNCTIONS AND MACROS
  153. ;;;
  154. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  155. ;;; Little Helpers
  156.  
  157. (defun SAME-JUSTIFICATION (j1 j2)
  158.   (declare (vector j1 j2) ; justification is unnamed type
  159.            (optimize (safety 1) (space 2) (speed 3)))
  160.   ;; The are the same if the warrant and grounds are the same.
  161.   (and (eq (justification-warrant j1) (justification-warrant j2))
  162.        (equal (justification-grounds j1) (justification-grounds j2))))
  163.  
  164. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  165. ;;; Processing and Recording data (needed by forward only, but provided
  166. ;;; for user's use in building datum DNETs regardless of direction.)
  167.  
  168. (defun ADD-DATUM-INTERNAL (datum dnet warrant grounds)
  169.   ;; Adds <datum> to <dnet> with justification recorded.  If already there,
  170.   ;; adds the new justification if it differs from existing justification.
  171.   (let ((justification 
  172.          (make-justification :warrant warrant 
  173.                              :grounds grounds
  174.                              :time (get-universal-time))))
  175.     (multiple-value-bind 
  176.       (newly-added dnet-terminal)
  177.       (dnet::indexpr-internal datum dnet (list justification))
  178.       (unless newly-added
  179.         (pushnew justification 
  180.                  (dnet-terminal-info dnet-terminal)
  181.                  :test #'same-justification))
  182.       (values newly-added dnet-terminal))))
  183.  
  184. (defun DELETE-DATUM-INTERNAL (datum dnet)
  185.   (dnet::delexpr-internal datum dnet))
  186.  
  187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  188. ;;;
  189. ;;;                        USER INTERFACE FUNCTIONS
  190. ;;;
  191. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  192.  
  193. (defmacro DEFVARIABLES (&rest variables)
  194.   "defvariables &rest <variables>                                      [Macro]
  195.   Defines all the given symbols or strings as variables."
  196.   (cons 'progn
  197.         (mapcar #'(lambda (v) (macroexpand (list 'dnet:defvariable v)))
  198.                 variables)))
  199.  
  200. (defun MAKE-DATA-BASE (name &key indexpr-hook delexpr-hook info)
  201.   "make-data-base <name> &key <indexpr-hook> <delexpr-hook> <info>  [Function]
  202.    Identical to DNET:MAKE-DNET (see it for documentation)."
  203.   (dnet:make-dnet name 
  204.                   :indexpr-hook indexpr-hook 
  205.                   :delexpr-hook delexpr-hook
  206.                   :info         info))
  207.  
  208. (defun MAKE-RULE-BASE (name &key indexpr-hook delexpr-hook info)
  209.   "make-rule-base <name> &key <indexpr-hook> <delexpr-hook> <info>  [Function]
  210.    Identical to DNET:MAKE-DNET (see it for documentation)."
  211.   (dnet:make-dnet name 
  212.                   :indexpr-hook indexpr-hook 
  213.                   :delexpr-hook delexpr-hook
  214.                   :info         info))
  215.  
  216. ;;;-----------------------------------------
  217. ;;; Processing and Recording datum.
  218.  
  219. (defun ADD-DATUM (datum dnet &key (warrant :asserted) (grounds nil))
  220.   "add-datum <datum> <dnet> &key warrant grounds                      [Function]
  221.   Places the <datum> in <dnet> with a justification constructed from the 
  222.   given <warrant> (rule, etc.) and <grounds> (antecedent).  Returns two
  223.   values: boolean whether added, and a DNET-TERMINAL (like DNET:INDEXPR)."
  224.   (assert (not-a-dotted-list datum) (datum)
  225.           "[RULE:ADD-DATUM] Dotted lists not allowed in DNET: ~S" datum)
  226.   (check-type dnet symbol)
  227.   (assert (sm:gets 'dnet dnet) (dnet) "[RULE:ADD-DATUM] ~S is not a known DNET." dnet)
  228.   (add-datum-internal datum dnet warrant grounds))
  229.  
  230. (defun DELETE-DATUM (datum dnet)
  231.   "add-datum <datum> <dnet>                                           [Function]
  232.   Removes the <datum> from the <dnet>.  Returns two values: boolean whether
  233.   deleted, and a DNET-TERMINAL (like DNET:DELEXPR)."
  234.   (assert (not-a-dotted-list datum) (datum)
  235.           "[RULE:DELETE-DATUM] Dotted lists not allowed in DNET: ~S" datum)
  236.   (check-type dnet symbol)
  237.   (assert (sm:gets 'dnet dnet) (dnet) "[RULE:DELETE-DATUM] ~S is not a known DNET." dnet)
  238.   (delete-datum-internal datum dnet))
  239.  
  240. (defun DATUM-JUSTIFICATION (datum dnet)
  241.   "datum-justification <datum> <dnet>                                 [Function]
  242.   Returns a justification structure recording the support for <datum> in 
  243.   <dnet>.  Justifications are maintained by ADD-DATUM and the forward 
  244.   chaining functions.  Returns NIL if the datum has not been recorded."
  245.   (check-type dnet symbol)
  246.   (assert (sm:gets 'dnet dnet) (dnet) 
  247.           "[DNET:DATUM-JUSTIFICATION] ~S is not a known DNET." dnet)
  248.   (multiple-value-bind
  249.     (recorded terminal)
  250.     (dnet::getexpr-internal datum dnet)
  251.     (if recorded (dnet-terminal-info terminal))))
  252.  
  253. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  254. (provide :rule-defs)
  255. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  256. ;;; the end.